home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / demos / stars.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-01-01  |  3.4 KB  |  156 lines
  1. PROGRAM Sterne;
  2.  
  3.  
  4. uses Exec, Graphics, Intuition, Utility, vartags;
  5.  
  6.  
  7.  
  8. CONST   MAX_STERNE = 42;
  9.         MAX_GESCHW = 15;
  10.  
  11. TYPE    Star = packed Record
  12.                  x,y :Integer;
  13.                  msin :Real;
  14.                  mcos :Real;
  15.                  d   :Integer;
  16.                  v   :Integer;
  17.                End;
  18.  
  19. VAR     Scr     :pScreen;
  20.         Win     :pWindow;
  21.         Msg     :pIntuiMessage;
  22.         Ende    :Boolean;
  23.         Stars   :Array[1..MAX_STERNE] of Star;
  24.         factor  :Real;
  25.         col     :Integer;
  26.         dum     :Longint;
  27.  
  28.  
  29. PROCEDURE newStern(num :Integer);
  30.  
  31. BEGIN
  32.   col:=Random(360);
  33.   Stars[num].x := Scr^.Width shr 1;
  34.   Stars[num].y := Scr^.Height shr 1;
  35.   Stars[num].msin := sin(col*factor);
  36.   Stars[num].mcos := cos(col*factor);
  37.   Stars[num].d := 0;
  38.   Stars[num].v := Random(MAX_GESCHW)+2;
  39. END;
  40.  
  41.  
  42. PROCEDURE moveStern(num :Integer);
  43.  
  44. BEGIN
  45.   Stars[num].d:=Stars[num].d+Stars[num].v;
  46.   Stars[num].x:=Round(Stars[num].d*Stars[num].msin)+Scr^.Width shr 1;
  47.   Stars[num].y:=Round(Stars[num].d*Stars[num].mcos)+Scr^.Height shr 1;
  48.   {Inc(Stars[num].v);}
  49. END;
  50.  
  51.  
  52. PROCEDURE drawSterne;
  53.  
  54. BEGIN
  55.   For dum:=1 to MAX_STERNE Do Begin
  56.     If Stars[dum].v=0 Then Begin
  57.       If Random(10)>4 Then
  58.         newStern(dum);
  59.     End Else If Stars[dum].d>Scr^.Width shr 1 Then Begin
  60.       SetAPen(Win^.RPort,0);
  61.       If WritePixel(Win^.RPort,(Stars[dum].x),(Stars[dum].y))=0 Then;
  62.       Stars[dum].v:=0;
  63.     End Else Begin
  64.       SetAPen(Win^.RPort,0);
  65.       If WritePixel(Win^.RPort,(Stars[dum].x),(Stars[dum].y))=0 Then;
  66.       moveStern(dum);
  67.       col:=(Stars[dum].d shl 5) Div Scr^.Height shr 1;
  68.       If col>7 Then
  69.         col:=7;
  70.       SetAPen(Win^.RPort,col);
  71.       If WritePixel(Win^.RPort,(Stars[dum].x),(Stars[dum].y))=0 Then;
  72.     End;
  73.   End;
  74. END;
  75.  
  76.  
  77. PROCEDURE initSterne;
  78.  
  79. BEGIN
  80.   For dum:=1 to MAX_STERNE Do begin
  81.     Stars[dum].x := Scr^.Width shr 1;
  82.     Stars[dum].y := Scr^.Height shr 1;
  83.     Stars[dum].msin := 0.0;
  84.     Stars[dum].mcos := 0.0;
  85.     Stars[dum].d := 0;
  86.     Stars[dum].v := 0;
  87.   end;
  88.   factor:=PI/180;
  89. END;
  90.  
  91.  
  92. PROCEDURE CleanUp(str:string; code : Longint);
  93.  
  94. BEGIN
  95.   If assigned(Win) Then
  96.     CloseWindow(Win);
  97.   If assigned(Scr) then CloseScreen(Scr);
  98.   if assigned(GfxBase) then CloseLibrary(GfxBase);
  99.   if str <> '' then writeln(str);
  100.   Halt(code);
  101. END;
  102.  
  103.  
  104. PROCEDURE Init;
  105.  
  106. BEGIN
  107.   GfxBase := OpenLibrary(GRAPHICSNAME,0);
  108.   if GfxBase = nil then CleanUp('no graphics.library',20);
  109.  
  110.   Scr:=Nil;  Win:=Nil;
  111.  
  112.   Scr := OpenScreenTagList(NIL,TAGS(
  113.                    SA_Depth,     3,
  114.                    SA_DisplayID, HIRES_KEY,
  115.                    TAG_END));
  116.  
  117.   If Scr=Nil Then CleanUp('No screen',20);
  118.  
  119.   Win:=OpenWindowTagList(Nil, TAGS(
  120.                         WA_Flags, WFLG_BORDERLESS,
  121.                         WA_IDCMP, IDCMP_MOUSEBUTTONS,
  122.                         WA_CustomScreen, Longint(Scr),
  123.                         TAG_DONE));
  124.  
  125.   If Win=Nil Then CleanUp('No window',20);
  126.  
  127.   initSterne;
  128.  
  129.   SetRGB4(@Scr^.ViewPort, 0, $0,$0,$0);
  130.   SetRGB4(@Scr^.ViewPort, 1, $3,$3,$3);
  131.   SetRGB4(@Scr^.ViewPort, 2, $6,$6,$6);
  132.   SetRGB4(@Scr^.ViewPort, 3, $b,$b,$b);
  133.   SetRGB4(@Scr^.ViewPort, 4, $c,$c,$c);
  134.   SetRGB4(@Scr^.ViewPort, 5, $d,$d,$d);
  135.   SetRGB4(@Scr^.ViewPort, 6, $e,$e,$e);
  136.   SetRGB4(@Scr^.ViewPort, 7, $f,$f,$f);
  137.  
  138. END;
  139.  
  140.  
  141.  
  142. BEGIN
  143.   Init;
  144.   Ende:=false;
  145.   Repeat
  146.     drawSterne;
  147.     Msg:=pIntuiMessage(GetMsg(Win^.UserPort));
  148.     If Msg<>Nil Then Begin
  149.       ReplyMsg(Pointer(Msg));
  150.       Ende:=true;
  151.     End;
  152.   Until Ende;
  153.   CleanUp('',0);
  154. END.
  155.  
  156.